home *** CD-ROM | disk | FTP | other *** search
/ Gigarom 1 / Gigarom Macintosh Archives (Quantum Leap)(CDRM1080320)(1993).iso / FILES / DEV / I-Z / Xlisp_Source.cpt / xlread.c < prev    next >
Text File  |  1980-01-01  |  8KB  |  408 lines
  1. /* xlread - xlisp expression input routine */
  2.  
  3. #include "xlisp.h"
  4.  
  5. /* external variables */
  6. extern NODE *s_stdout,*true;
  7. extern NODE *s_quote,*s_function,*s_bquote,*s_comma,*s_comat;
  8. extern NODE *xlstack;
  9. extern int xlplevel;
  10.  
  11. /* external routines */
  12. extern FILE *fopen();
  13.  
  14. /* forward declarations */
  15. FORWARD NODE *plist();
  16. FORWARD NODE *pstring();
  17. FORWARD NODE *pquote();
  18. FORWARD NODE *pname();
  19.  
  20. /* xlload - load a file of xlisp expressions */
  21. int xlload(fname,vflag,pflag)
  22.   char *fname; int vflag,pflag;
  23. {
  24.     NODE *oldstk,fptr,*ofptr,expr;
  25.     CONTEXT cntxt;
  26.     int sts;
  27.  
  28.     /* create a new stack frame */
  29.     oldstk = xlsave(&fptr,&expr,NULL);
  30.  
  31.     /* allocate a file node */
  32.     fptr.n_ptr = newnode(FPTR);
  33.     fptr.n_ptr->n_fp = NULL;
  34.     fptr.n_ptr->n_savech = 0;
  35.  
  36.     /* print the information line */
  37.     if (vflag) {
  38.     ofptr = s_stdout->n_symvalue;
  39.     xlputstr(ofptr,"; loading \"");
  40.     xlputstr(ofptr,fname);
  41.     xlputstr(ofptr,"\"\n");
  42.     }
  43.     
  44.     /* open the file */
  45.     if ((fptr.n_ptr->n_fp = fopen(fname,"r")) == NULL) {
  46.     xlstack = oldstk;
  47.     return (FALSE);
  48.     }
  49.  
  50.     /* read, evaluate and possibly print each expression in the file */
  51.     xlbegin(&cntxt,CF_ERROR,true);
  52.     if (setjmp(cntxt.c_jmpbuf))
  53.     sts = FALSE;
  54.     else {
  55.     while (xlread(fptr.n_ptr,&expr.n_ptr)) {
  56.         expr.n_ptr = xleval(expr.n_ptr);
  57.         if (pflag)
  58.         stdprint(expr.n_ptr);
  59.     }
  60.     sts = TRUE;
  61.     }
  62.     xlend(&cntxt);
  63.  
  64.     /* close the file */
  65.     fclose(fptr.n_ptr->n_fp);
  66.     fptr.n_ptr->n_fp = NULL;
  67.  
  68.     /* restore the previous stack frame */
  69.     xlstack = oldstk;
  70.  
  71.     /* return status */
  72.     return (sts);
  73. }
  74.  
  75. /* xlread - read an xlisp expression */
  76. int xlread(fptr,pval)
  77.   NODE *fptr,**pval;
  78. {
  79.     /* initialize */
  80.     xlplevel = 0;
  81.  
  82.     /* parse an expression */
  83.     return (parse(fptr,pval));
  84. }
  85.  
  86. /* parse - parse an xlisp expression */
  87. LOCAL int parse(fptr,pval)
  88.   NODE *fptr,**pval;
  89. {
  90.     int ch;
  91.  
  92.     /* keep looking for a node skipping comments */
  93.     while (TRUE)
  94.  
  95.     /* check next character for type of node */
  96.     switch (ch = nextch(fptr)) {
  97.     case EOF:
  98.         xlgetc(fptr);
  99.         return (FALSE);
  100.     case '\'':            /* a quoted expression */
  101.         xlgetc(fptr);
  102.         *pval = pquote(fptr,s_quote);
  103.         return (TRUE);
  104.     case '#':            /* a quoted function */
  105.         xlgetc(fptr);
  106.         if ((ch = xlgetc(fptr)) == '<')
  107.             xlfail("unreadable atom");
  108.         else if (ch != '\'')
  109.             xlfail("expected quote after #");
  110.         *pval = pquote(fptr,s_function);
  111.         return (TRUE);
  112.     case '`':            /* a back quoted expression */
  113.         xlgetc(fptr);
  114.         *pval = pquote(fptr,s_bquote);
  115.         return (TRUE);
  116.     case ',':            /* a comma or comma-at expression */
  117.         xlgetc(fptr);
  118.         if (xlpeek(fptr) == '@') {
  119.             xlgetc(fptr);
  120.             *pval = pquote(fptr,s_comat);
  121.         }
  122.         else
  123.             *pval = pquote(fptr,s_comma);
  124.         return (TRUE);
  125.     case '(':            /* a sublist */
  126.         *pval = plist(fptr);
  127.         return (TRUE);
  128.     case ')':            /* closing paren - shouldn't happen */
  129.         xlfail("extra right paren");
  130.     case '.':            /* dot - shouldn't happen */
  131.         xlfail("misplaced dot");
  132.     case ';':            /* a comment */
  133.         pcomment(fptr);
  134.         break;
  135.     case '"':            /* a string */
  136.         *pval = pstring(fptr);
  137.         return (TRUE);
  138.     default:
  139.         if (issym(ch))        /* a name */
  140.             *pval = pname(fptr);
  141.         else
  142.             xlfail("invalid character");
  143.         return (TRUE);
  144.     }
  145. }
  146.  
  147. /* pcomment - parse a comment */
  148. LOCAL pcomment(fptr)
  149.   NODE *fptr;
  150. {
  151.     int ch;
  152.  
  153.     /* skip to end of line */
  154.     while ((ch = checkeof(fptr)) != EOF && ch != '\n')
  155.     ;
  156. }
  157.  
  158. /* plist - parse a list */
  159. LOCAL NODE *plist(fptr)
  160.   NODE *fptr;
  161. {
  162.     NODE *oldstk,val,*lastnptr,*nptr,*p;
  163.     int ch;
  164.  
  165.     /* increment the nesting level */
  166.     xlplevel += 1;
  167.  
  168.     /* create a new stack frame */
  169.     oldstk = xlsave(&val,NULL);
  170.  
  171.     /* skip the opening paren */
  172.     xlgetc(fptr);
  173.  
  174.     /* keep appending nodes until a closing paren is found */
  175.     lastnptr = NIL;
  176.     for (lastnptr = NIL; (ch = nextch(fptr)) != ')'; lastnptr = nptr) {
  177.  
  178.     /* check for end of file */
  179.     if (ch == EOF)
  180.         badeof(fptr);
  181.  
  182.     /* check for a dotted pair */
  183.     if (ch == '.') {
  184.  
  185.         /* skip the dot */
  186.         xlgetc(fptr);
  187.  
  188.         /* make sure there's a node */
  189.         if (lastnptr == NIL)
  190.         xlfail("invalid dotted pair");
  191.  
  192.         /* parse the expression after the dot */
  193.         if (!parse(fptr,&p))
  194.         badeof(fptr);
  195.         rplacd(lastnptr,p);
  196.  
  197.         /* make sure its followed by a close paren */
  198.         if (nextch(fptr) != ')')
  199.         xlfail("invalid dotted pair");
  200.  
  201.         /* done with this list */
  202.         break;
  203.     }
  204.  
  205.     /* allocate a new node and link it into the list */
  206.     nptr = newnode(LIST);
  207.     if (lastnptr == NIL)
  208.         val.n_ptr = nptr;
  209.     else
  210.         rplacd(lastnptr,nptr);
  211.  
  212.     /* initialize the new node */
  213.     if (!parse(fptr,&p))
  214.         badeof(fptr);
  215.     rplaca(nptr,p);
  216.     }
  217.  
  218.     /* skip the closing paren */
  219.     xlgetc(fptr);
  220.  
  221.     /* restore the previous stack frame */
  222.     xlstack = oldstk;
  223.  
  224.     /* decrement the nesting level */
  225.     xlplevel -= 1;
  226.  
  227.     /* return successfully */
  228.     return (val.n_ptr);
  229. }
  230.  
  231. /* pstring - parse a string */
  232. LOCAL NODE *pstring(fptr)
  233.   NODE *fptr;
  234. {
  235.     NODE *oldstk,val;
  236.     char sbuf[STRMAX+1];
  237.     int ch,i,d1,d2,d3;
  238.  
  239.     /* create a new stack frame */
  240.     oldstk = xlsave(&val,NULL);
  241.  
  242.     /* skip the opening quote */
  243.     xlgetc(fptr);
  244.  
  245.     /* loop looking for a closing quote */
  246.     for (i = 0; i < STRMAX && (ch = checkeof(fptr)) != '"'; i++) {
  247.     switch (ch) {
  248.     case EOF:
  249.         badeof(fptr);
  250.     case '\\':
  251.         switch (ch = checkeof(fptr)) {
  252.         case 'e':
  253.             ch = '\033';
  254.             break;
  255.         case 'n':
  256.             ch = '\n';
  257.             break;
  258.         case 'r':
  259.             ch = '\r';
  260.             break;
  261.         case 't':
  262.             ch = '\t';
  263.             break;
  264.         default:
  265.             if (ch >= '0' && ch <= '7') {
  266.                 d1 = ch - '0';
  267.                 d2 = checkeof(fptr) - '0';
  268.                 d3 = checkeof(fptr) - '0';
  269.                 ch = (d1 << 6) + (d2 << 3) + d3;
  270.             }
  271.             break;
  272.         }
  273.     }
  274.     sbuf[i] = ch;
  275.     }
  276.     sbuf[i] = 0;
  277.  
  278.     /* initialize the node */
  279.     val.n_ptr = newnode(STR);
  280.     val.n_ptr->n_str = strsave(sbuf);
  281.     val.n_ptr->n_strtype = DYNAMIC;
  282.  
  283.     /* restore the previous stack frame */
  284.     xlstack = oldstk;
  285.  
  286.     /* return the new string */
  287.     return (val.n_ptr);
  288. }
  289.  
  290. /* pquote - parse a quoted expression */
  291. LOCAL NODE *pquote(fptr,sym)
  292.   NODE *fptr,*sym;
  293. {
  294.     NODE *oldstk,val,*p;
  295.  
  296.     /* create a new stack frame */
  297.     oldstk = xlsave(&val,NULL);
  298.  
  299.     /* allocate two nodes */
  300.     val.n_ptr = newnode(LIST);
  301.     rplaca(val.n_ptr,sym);
  302.     rplacd(val.n_ptr,newnode(LIST));
  303.  
  304.     /* initialize the second to point to the quoted expression */
  305.     if (!parse(fptr,&p))
  306.     badeof(fptr);
  307.     rplaca(cdr(val.n_ptr),p);
  308.  
  309.     /* restore the previous stack frame */
  310.     xlstack = oldstk;
  311.  
  312.     /* return the quoted expression */
  313.     return (val.n_ptr);
  314. }
  315.  
  316. /* pname - parse a symbol name */
  317. LOCAL NODE *pname(fptr)
  318.   NODE *fptr;
  319. {
  320.     char sname[STRMAX+1];
  321.     NODE *val;
  322.     int i;
  323.  
  324.     /* get symbol name */
  325.     for (i = 0; i < STRMAX && issym(xlpeek(fptr)); )
  326.     sname[i++] = xlgetc(fptr);
  327.     sname[i] = 0;
  328.  
  329.     /* check for a number or enter the symbol into the oblist */
  330.     return (isnumber(sname,&val) ? val : xlenter(sname,DYNAMIC));
  331. }
  332.  
  333. /* nextch - look at the next non-blank character */
  334. LOCAL int nextch(fptr)
  335.   NODE *fptr;
  336. {
  337.     int ch;
  338.  
  339.     /* return and save the next non-blank character */
  340.     while ((ch = xlpeek(fptr)) != EOF && isspace(ch))
  341.     xlgetc(fptr);
  342.     return (ch);
  343. }
  344.  
  345. /* checkeof - get a character and check for end of file */
  346. LOCAL int checkeof(fptr)
  347.   NODE *fptr;
  348. {
  349.     int ch;
  350.  
  351.     if ((ch = xlgetc(fptr)) == EOF)
  352.     badeof(fptr);
  353.     return (ch);
  354. }
  355.  
  356. /* badeof - unexpected eof */
  357. LOCAL badeof(fptr)
  358.   NODE *fptr;
  359. {
  360.     xlgetc(fptr);
  361.     xlfail("unexpected EOF");
  362. }
  363.  
  364. /* isnumber - check if this string is a number */
  365. int isnumber(str,pval)
  366.   char *str; NODE **pval;
  367. {
  368.     char *p;
  369.     int d;
  370.  
  371.     /* initialize */
  372.     p = str; d = 0;
  373.  
  374.     /* check for a sign */
  375.     if (*p == '+' || *p == '-')
  376.     p++;
  377.  
  378.     /* check for a string of digits */
  379.     while (isdigit(*p))
  380.     p++, d++;
  381.  
  382.     /* make sure there was at least one digit and this is the end */
  383.     if (d == 0 || *p)
  384.     return (FALSE);
  385.  
  386.     /* convert the string to an integer and return successfully */
  387.     *pval = newnode(INT);
  388.     (*pval)->n_int = atoi(*str == '+' ? ++str : str);
  389.     return (TRUE);
  390. }
  391.  
  392. /* issym - check whether a character if valid in a symbol name */
  393. LOCAL int issym(ch)
  394.   int ch;
  395. {
  396.     if (ch <= ' ' || ch >= 0177 ||
  397.         ch == '(' ||
  398.         ch == ')' ||
  399.         ch == ';' || 
  400.     ch == ',' ||
  401.     ch == '`' ||
  402.         ch == '"' ||
  403.         ch == '\'')
  404.     return (FALSE);
  405.     else
  406.     return (TRUE);
  407. }
  408.